COMMENT ⊗   VALID 00007 PAGES 
RECORD PAGE   DESCRIPTION
 00001 00001
 00002 00002	FORSER - service routines - ISIGN, SIGN, AMOD
 00004 00003	_ NON0, DISX, DIXY
 00006 00004	_ KARN
 00009 00005	_ KARN cont.-	Check for collinear case, if switch is on.
 00011 00006	_ KARN cont
 00014 00007	_ KOT, TRX, TRY, INREK
 00019 ENDMK
⊗;
COMMENT	FORSER - service routines - ISIGN, SIGN, AMOD
	These are routines that are not directly related to the
     	upkeep of the data-structure, nor to the line-fit, nor to the
	object abstraction schemes.;

ENTRY ISIGN,SIGN,AMOD,NON0,KARN,DISX,DISY,KOT,TRX,TRY,INREK;

BEGIN "FORSER"

DEFINE  QEP="EXTERNAL SIMPLE PROCEDURE",
	QFORP="FORWARD INTERNAL SIMPLE REAL PROCEDURE",
	QR="REAL",
	QRR="REFERENCE REAL",
	_="COMMENT";

EXTERNAL INTEGER DRX,DRY;

EXTERNAL REAL IRX,IRY,DSCX,DSCY;

REAL A11, A12, A21, A22, X00, Y00;

QEP REKOP(QR R,S,T,U,V; QRR W);
QFORP TRX(QR R,S);
QFORP TRY(QR R,S);


_ return I with the sign of J (integer values);

INTERNAL SIMPLE INTEGER PROCEDURE ISIGN(INTEGER I,J);
	RETURN(IF J<0 THEN -(ABS I) ELSE ABS I);


_ return R with the sign of S (real values);

INTERNAL SIMPLE REAL PROCEDURE SIGN(REAL R,S);
	RETURN(IF S<0. THEN -(ABS R) ELSE ABS R);


_ return R MOD S;

INTERNAL SIMPLE REAL PROCEDURE AMOD(REAL R,S);
	BEGIN "AMOD"
	INTEGER I;
	I←(R+SIGN(0.0001*S,R))/S;
	RETURN(IF I<0 THEN 0. MIN (R-S*(I+1)) ELSE 0. MAX (R-S*I))
	END "AMOD";
_ NON0, DISX, DIXY;

_ if R is very close to zero, return small non-zero value with right sign;

INTERNAL SIMPLE REAL PROCEDURE NON0(REAL R);
	RETURN(SIGN(ABS R MAX 0.000001,R));


_	Transforms X-coordinate from internal to display.;

INTERNAL SIMPLE INTEGER PROCEDURE DISX(REAL X);
	RETURN(0.5+DRX+DSCX*(X-IRX));


_	Transforms Y-coordinate from internal to display.;

INTERNAL SIMPLE INTEGER PROCEDURE DISY(REAL Y);
	RETURN(0.5+DRY+DSCY*(Y-IRY));
_ KARN;

_	Finds intersection (X1,Y1)-(X2,Y2) X (X3,Y3)-(X4,Y4) = (X,Y).
	IXN ← 1 (else 2) iff line N is closer in slope to X- than to Y-axis.
	IPN ← End on line N, which is closest to (X,Y). IPN ← 1 or 2.
	IPN is negated iff (X,Y) is actually inside line-segment N.
	RN  ← Squared distance from that end to (X,Y). IPN ← 0, and
	RN ← 900000., iff there is no intersection (slopes are too close).
	If the lines are collinear (exception to last sentence), and we
	ask for that case, the center point between their close ends is
	returned as the point of intersection (and other parameters are set
	accordingly). IC defines what is to be done, as follows:

	IC =  0	  Both cases are treated equally.
	IC = -1   Looks for collinearities only.
	IC =  1   Looks for intersections only.

	KARN returns  0 iff lines are  parallel, but not collinear,
		     -1 iff lines are collinear, and
		      1 iff lines intersect somewhere.
		 -(1+N) iff line N (i or 2) is gobbled by line (2-N).;


INTERNAL SIMPLE INTEGER PROCEDURE KARN(REAL X1,Y1,X2,Y2,X3,Y3,X4,Y4;
	       REFERENCE REAL X,Y; REFERENCE INTEGER IX1,IX2,IP1,IP2;
	       REFERENCE REAL R1,R2; INTEGER IC; REAL WI);
	BEGIN "KARN"
	LABEL L70,L71,L710,L1,L10,L11,L110,L2,L3,L5,L6,L13,L12,L14;
	REAL YD1,YD2,XD1,XD2,XP,YP,XQ,YQ,RDUM,AK1,AK2,DK,D1,D2,S1,S2,XA,YA,
		XB,YB;
	INTEGER IRET,GOBBLE;

	IRET←GOBBLE←0;
	IX1←1;
	IX2←1;
	IP1←0;
	IP2←0;
	R1←900000.;
	R2←900000.;
	YD1←Y1-Y2;
	YD2←Y3-Y4;
	XD1←X1-X2;
	XD2←X3-X4;
	IF ABS YD1 > ABS XD1 THEN IX1←2;
	IF ABS YD2 > ABS XD2 THEN IX2←2;
_ KARN cont.-	Check for collinear case, if switch is on.;

	IF IC=1 THEN GO L1;
	D1←0.25*(X1+X2+X3+X4);
	D2←0.25*(Y1+Y2+Y3+Y4);
	XP←X1;
	YP←Y1;
	IF (XP-D1)↑2+(YP-D2)↑2≤(X2-D1)↑2+(Y2-D2)↑2 THEN GO L70;
	XP←X2;
	YP←Y2;
L70:	XQ←X3;
	YQ←Y3;
	XA←X1+X2-XP;
	YA←Y1+Y2-YP;
	IF (XA-XQ)↑2+(YA-YQ)↑2≤(XA-X4)↑2+(YA-Y4)↑2 THEN GO L71;
	XQ←X4;
	YQ←Y4;

_	If lines are anywhere near collinear, (XP,YP) and (XQ,YQ) are
	the coordinates of the closest ends.;

L71:	XB←X3+X4-XQ;
	YB←Y3+Y4-YQ;

_	First check if either line might overlap the other entirely.;

	D1←(X1-X2)↑2+(Y1-Y2)↑2;
	D2←(X3-X4)↑2+(Y3-Y4)↑2;
	IF (RDUM←(XA-XB)↑2+(YA-YB)↑2)<D1∨RDUM<D2 THEN IF D1<D2 THEN
		BEGIN
		XP←X1;
		YP←Y1;
		XQ←X2;
		YQ←Y2;
		XA←X3;
		YA←Y3;
		XB←X4;
		YB←Y4;
		GOBBLE←1
		END ELSE BEGIN
		XP←X3;
		YP←Y3;
		XQ←X4;
		YQ←Y4;
		XA←X1;
		YA←Y1;
		XB←X2;
		YB←Y2;
		GOBBLE←2
		END;
    	X←X3+X4-XQ;
	Y←Y3+Y4-YQ;
_ KARN cont;

_	THE OVERSHOOT CHECK HAS EXPERIMENTALLY BEEN COMMENTED OUT
	IF (XQ-X)↑2+(YQ-Y)↑2-(XP-X)↑2-(YP-Y)↑2>0.5 THEN GO L710;

_	OK. Now set up the rectangular operator coordinate transform.;

	REKOP(XA,YA,XB,YB,WI,RDUM);

_	Use the transform for the elliptic operator test.;

	IF TRX(XP,YP)↑2+TRY(XP,YP)↑2≤1.∧TRX(XQ,YQ)↑2+TRY(XQ,YQ)↑2≤1.
		THEN IF GOBBLE THEN RETURN(-1-GOBBLE) ELSE IRET←-1;

_	If lines are not collinear, and IC=0, try intersection.;

L710:	IF IRET+IC=0 THEN GO L1;

_	If lines are not collinear, but IC=-1, we return.;

	IF IRET=0 THEN RETURN(IRET);

_	Lines are collinear. IC=0 or IC=-1. In either case, update parameters
	to be returned, using intersection case, and then exit.;

	X←0.5*(XP+XQ);
	Y←0.5*(YP+YQ);
	GO L110;

L1:	AK1←1000.;
	IF ABS XD1 > 0.005 THEN AK1←YD1/XD1;
	IF ABS AK1 > 1000. THEN AK1←1000.;
	AK2←1000.;
	IF ABS XD2 > 0.005 THEN AK2←YD2/XD2;
	IF ABS AK2 > 1000. THEN AK2←1000.;
	IF ABS AK1 > 50. ∧ ABS AK2 > 50. THEN RETURN(IRET);
	DK←AK1-AK2;
	IF ABS DK < 0.2 THEN RETURN(IRET);
	X←(AK1*X1-Y1+Y3-AK2*X3)/DK;
	IF X<-50.∨X>360. THEN RETURN(IRET);
	IF ABS AK1 < ABS AK2 THEN GO L10;
	Y←Y3+AK2*(X-X3);
	GO L11;

L10:	Y←Y1+AK1*(X-X1);
L11:	IF Y<-50.∨Y>290. THEN RETURN(IRET);
	IRET←1;
L110:	IF IX1=2 THEN GO L2;
	D1←X-X1;
	D2←X-X2;
	GO L3;

L2:	D1←Y-Y1;
	D2←Y-Y2;
L3:	S1← ABS D1 - ABS D2;
	S2←D1*D2;
	IP1←2;
	IF S1<0. THEN IP1←1;
	IF S2<0. THEN IP1←-IP1;
	IF IX2=2 THEN GO L5;
	D1←X-X3;
	D2←X-X4;
	GO L6;

L5:	D1←Y-Y3;
	D2←Y-Y4;
L6:	S1← ABS D1 - ABS D2;
	S2←D1*D2;
	IP2←2;
	IF S1<0. THEN IP2←1;
	IF S2<0. THEN IP2←-IP2;
	IF ABS IP1 = 2 THEN GO L13;
	R1←(X-X1)↑2+(Y-Y1)↑2;
	GO L12;

L13:	R1←(X-X2)↑2+(Y-Y2)↑2;
L12:	IF ABS IP2 = 2 THEN GO L14;
	R2←(X-X3)↑2+(Y-Y3)↑2;
	RETURN(IRET);

L14:	R2←(X-X4)↑2+(Y-Y4)↑2;
	RETURN(IRET)
	END "KARN";
_ KOT, TRX, TRY, INREK;


_	Computes transformation matrix from internal representation
	into coordinate system where origin = (X1,Y1), and the new
	X- and Y-axes end at (X2,Y2) and (X3,Y3), respectively.;

INTERNAL SIMPLE PROCEDURE KOT(REAL X1,Y1,X2,Y2,X3,Y3);
	BEGIN "KOT"
	REAL DX2,DY2,DX3,DY3,Q2,Q3;

	DY2←SIGN(ABS(DX2←Y2-Y1) MAX 0.000001,DX2);
	DY3←SIGN(ABS(DX3←Y3-Y1) MAX 0.000001,DX3);
	DX2←X2-X1;
	DX3←X3-X1;
	Q2←DX2/DY2;
	Q3←DX3/DY3;
	A11←1./(DX2-Q3*DY2);
	A21←1./(DX3-Q2*DY3);

_	Note that e.g. DX2-Q3*DY2=0 would imply parallelity of the axes.
	Also e.g. DX2 and DX3 cannot simultaneously be 0.;

	A12←1./(DY2-DX2/NON0(Q3));
	A22←1./(DY3-DX3/NON0(Q2));
	X00←X1;
	Y00←Y1
	END "KOT";


_	Transforms internal (X,Y) into new X-coordinate.;

INTERNAL SIMPLE REAL PROCEDURE TRX(REAL X,Y);
	RETURN(A11*(X-X00)+A12*(Y-Y00));


_	Transforms internal (X,Y) into new Y-coordinate.;

INTERNAL SIMPLE REAL PROCEDURE TRY(REAL X,Y);
	RETURN(A21*(X-X00)+A22*(Y-Y00));


_	Returns T (else F) iff (X,Y) is inside current rectangular operator.;

INTERNAL SIMPLE INTEGER PROCEDURE INREK(REAL X,Y);
	RETURN(ABS TRX(X,Y)≤1.∧ABS TRY(X,Y)≤1.);

	END "FORSER";